home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Modules / do-macs.em < prev    next >
Lisp/Scheme  |  1992-10-06  |  5KB  |  236 lines
  1. ; simple C-like loop macros
  2. ;
  3. ; (for initial test iteration form form ... )
  4. ;    value is the value of the last form
  5. ;
  6. ; (while test form form ... )
  7. ;    value is the value of the last form
  8. ;
  9. ; (do form form ... form (while test))
  10. ;    value is the value of the last form
  11. ;    implicit progn in while clause
  12. ;
  13. ; (break form form ... )
  14. ;    exit the innermost loop, returning the value of the last form
  15. ;
  16. ; (continue)
  17. ;    skip to the end of the innermost loop
  18.  
  19. ; (setq |@loopy-final-value@| ... ) should be
  20. ; (setq |@loopy-final-value@| (values ... ))
  21.  
  22.  
  23. (defmodule do-macs
  24.  
  25.   (standard trace)
  26.   ()
  27.  
  28.  
  29.   (defmacro for (init test iter . body)
  30.     `(progn ,init
  31.         (while ,test
  32.           ,@body
  33.           ,iter)))
  34.   (export for)
  35.  
  36.   (defun map-range (f s e)
  37.     (if (> s e) ()
  38.       (progn
  39.         (f s)
  40.         (map-range f (+ s 1) e))))
  41.  
  42.   (defmacro dotimes (var start end . body)
  43.     `(map-range
  44.       (lambda (,var) ,@body)
  45.       ,start ,end))
  46.  
  47.   (export map-range dotimes)
  48.  
  49.   (defmacro ++ (form . vals)
  50.     (cond ((atom form)
  51.        `(setq ,form (+ ,form 1)))
  52.       ((eq (car form) 'dynamic)
  53.        `(dynamic-setq ,(cadr form) (+ ,form 1)))
  54.       (t
  55.        `((setter ,(car form)) ,(cadr form) (+ ,form 1)))))         
  56.  
  57.   (defmacro -- (form)
  58.     (cond ((atom form)
  59.        `(setq ,form (- ,form 1)))
  60.       ((eq (car form) 'dynamic)
  61.        `(dynamic-setq ,(cadr form) (- ,form 1)))
  62.       (t
  63.        `((setter ,(car form)) ,(cadr form) (- ,form 1)))))         
  64.  
  65.   (export ++ --)
  66.  
  67.   (defmacro setf (form val)
  68.     (cond ((atom form)
  69.        `(setq ,form ,val))
  70.       ((eq (car form) 'dynamic)
  71.        `(dynamic-setq ,(cadr form) ,val))
  72.       (t
  73.            `(let ((@-woo-woo-@ ,val))
  74.           ((setter ,(car form)) ,@(cdr form) @-woo-woo-@)
  75.           @-woo-woo-@))))
  76.  
  77.   (export setf)
  78.  
  79.  
  80.   (defmacro break forms
  81.     `(@break-cont@ (progn ,@forms)))
  82.  
  83.   (defmacro continue ()
  84.     `(@continue-cont@ '(() t)))
  85.  
  86.   (defmacro while (pred . forms)
  87.     `(let/cc @break-cont@
  88.          (map-while (lambda (@continue-cont@) ,@forms)
  89.             (lambda () ,pred)
  90.             ())))
  91.  
  92.   (defun map-while (ff pf val)
  93.     (let ((ans (let/cc cc (map-while-cont ff pf cc val))))
  94.       (if (cdr ans)
  95.       (map-while ff pf val)
  96.     (car ans))))
  97.  
  98.   (defun map-while-cont (ff pf cc val)
  99.     (if (pf)
  100.     (map-while-cont ff pf cc (ff cc))
  101.       (cons val ())))
  102.  
  103.   (defmacro docdr (var arglis . body)
  104.     `(when (not (null ,arglis))
  105.        (let ((,var  ,arglis)
  106.          (rest (cdr ,arglis)))
  107.          (while ,var
  108.            (when ,var
  109.              ,@body
  110.              (if rest
  111.              (progn
  112.                (setq ,var  rest)
  113.                (setq rest (cdr rest)))
  114.                (setq ,var nil)))))))
  115.  
  116.   (export docdr)
  117.  
  118.   (defmacro docollect (var arg-lis . body)
  119.     `(when (not (null ,arg-lis))
  120.        (let ((,var (car ,arg-lis))
  121.          (rest (cdr ,arg-lis))
  122.          (new-lis nil))
  123.          (while ,var
  124.            (when ,var
  125.              (setq new-lis  (append new-lis (list (progn ,@body))))
  126.              (if rest
  127.              (progn
  128.                (setq ,var (car rest))
  129.                (setq rest (cdr rest)))
  130.                (setq ,var nil))))
  131.          new-lis)))
  132.  
  133.   (export docollect)
  134.  
  135.   (defmacro docollect-unique (var arg-lis . body)
  136.     `(when (not (null ,arg-lis))
  137.        (let ((,var (car ,arg-lis))
  138.          (rest (cdr ,arg-lis))
  139.          (new-lis nil)
  140.          (temp nil))
  141.          (while ,var
  142.            (when (not (memq (setq temp (progn ,@body)) new-lis))
  143.              (setq new-lis  (append new-lis (list temp))))
  144.            (if rest
  145.            (progn
  146.              (setq ,var (car rest))
  147.              (setq rest (cdr rest)))
  148.          (setq ,var nil)))
  149.          new-lis)))
  150.  
  151.   (export docollect-unique)
  152.  
  153.   ;; List macros...
  154.  
  155.   (defmacro push (val st) `(setq ,st (cons ,val ,st)))
  156.  
  157.  
  158.   (defmacro pop (st) `(let ((val (car ,st)))
  159.             (setq ,st (cdr ,st))
  160.             val))
  161.   (export push pop)
  162.  
  163.   (defmacro incf (arg)
  164.     `(setq ,arg (+ 1 ,arg)))
  165.  
  166.   (export incf)
  167.  
  168.   (defmacro decf (arg)
  169.     `(setq ,arg (- ,arg 1)))
  170.  
  171.   (export decf)
  172.  
  173.   (defmacro trap (value . forms)
  174.     `(let/cc escape
  175.          (with-handler (lambda (a b) (escape ,value)) ,@forms)))
  176.  
  177.   (export trap)
  178.  
  179.   (defmacro multiple-setq forms
  180.     (if forms
  181.     `(progn 
  182.        (setq ,(car forms) ,(cadr forms))
  183.        (multiple-setq ,@(cddr forms)))
  184.       `(progn nil)))
  185.  
  186.   (export multiple-setq)
  187.  
  188.   (defmacro dolist (var arglist . body)
  189.     `(mapc (lambda (,var) ,@body) ,arglist))
  190.  
  191.   (export dolist)
  192.  
  193.   (defmacro do* (control test-result . body)
  194.     (let ((decl nil) (label (gensym)) (vl nil) (step nil)
  195.           (test (car test-result))
  196.           (result (cdr test-result)))
  197.       (mapc (lambda (c)
  198.           (when (symbolp c) (setq c (list c)))
  199.           (setq vl (cons (list (car c) (cadr c)) vl))
  200.           (unless (not (consp (cddr c)))
  201.               (setq step (cons (car c) step))
  202.               (setq step (cons (caddr c) step))))
  203.         control)
  204.       
  205.       `(let* ,(reverse vl)
  206.                     ;     ,@decl
  207.      (while (not ,test) 
  208.        (progn ,@body)
  209.        (multiple-setq ,@(reverse step)))
  210.      (progn ,@result))))
  211.  
  212.   (export do*)  
  213.  
  214.   (export break continue while map-while map-while-cont)
  215.  
  216.   (defmacro prog x `(progn ,@x))
  217.   (export prog)
  218.  
  219.   (defmacro do body
  220.     (let* ((revbody (reverse body))
  221.        (while-clause (car revbody))
  222.        (test (if (and (consp while-clause)
  223.                           (eq (car while-clause) 'while))
  224.                      (cdr while-clause)
  225.            (list while-clause)))
  226.            (newbody (reverse (cdr revbody))))
  227.       `(let ((@-res-@ nil))
  228.      (while (progn (setq @-res-@ (progn ,@newbody))
  229.                (progn ,@test))
  230.        nil)
  231.      @-res-@)))
  232.  
  233.   (export do)
  234.  
  235.   )
  236.